home *** CD-ROM | disk | FTP | other *** search
/ Whiteline: Alpha / Whiteline Alpha.iso / progtool / pascal / o_gem / source / spdotest / spdotest.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-09-22  |  11.6 KB  |  462 lines
  1. {$IFDEF DEBUG}
  2.     {$B+,D+,G-,I-,L+,N-,P-,Q+,R+,S+,T-,V-,X+,Z+}
  3. {$ELSE}
  4.     {$B+,D-,G-,I-,L-,N-,P-,Q-,R-,S-,T-,V-,X+,Z+}
  5. {$ENDIF}
  6.  
  7. program SpeedoTest;
  8.  
  9. uses
  10.  
  11.     Tos,Gem,OTypes,OProcs,OWindows,ODialogs;
  12.  
  13. const
  14.  
  15.     {$I spdotest.i}
  16.  
  17. type
  18.  
  19.     TSpApplication = object(TApplication)
  20.         fntIndx,
  21.         fntColor: integer;
  22.         fntName : string;
  23.         procedure SetupVDI; virtual;
  24.         procedure InitInstance; virtual;
  25.         procedure InitMainWindow; virtual;
  26.     end;
  27.  
  28.     PSpWindow = ^TSpWindow;
  29.     TSpWindow = object(TWindow)
  30.         oldWidth: integer;
  31.         ts      : array [0..2] of string;
  32.         fs,
  33.         fy,
  34.         offs    : array [0..3] of integer;
  35.         function CanClose: boolean; virtual;
  36.         procedure GetWindowClass(var AWndClass: TWndClass); virtual;
  37.         function GetClassName: string; virtual;
  38.         procedure Paint(var PaintInfo: TPaintStruct); virtual;
  39.         procedure WMClick(mX,mY,KStat: integer); virtual;
  40.         procedure GetWorkMin(var minX,minY: integer); virtual;
  41.     end;
  42.  
  43.     TTransRec = record
  44.         fc,
  45.         bc: array [0..7] of integer
  46.     end;
  47.  
  48.     PSpDialog = ^TSpDialog;
  49.     TSpDialog = object(TDialog)
  50.         TransRec: TTransRec;
  51.         okBtn   : PButton;
  52.         function GetStyle: integer; virtual;
  53.         procedure WMClosed; virtual;
  54.         function OK: boolean; virtual;
  55.         function Cancel: boolean; virtual;
  56.         function Help: boolean; virtual;
  57.         procedure CallChanged(Indx: integer; dclk,edt,push: boolean); virtual;
  58.     end;
  59.  
  60.     PAbout = ^TAbout;
  61.     TAbout = object(TKeyMenu)
  62.         procedure Work; virtual;
  63.     end;
  64.  
  65.     PAttr = ^TAttr;
  66.     TAttr = object(TKeyMenu)
  67.         procedure Work; virtual;
  68.     end;
  69.  
  70.     PFont = ^TFont;
  71.     TFont = object(TKeyMenu)
  72.         procedure Work; virtual;
  73.     end;
  74.  
  75. var
  76.  
  77.     SpApp: TSpApplication;
  78.  
  79.  
  80. function vqt_name(handle,element_num: integer; var name: string; var index: integer): boolean;
  81.     var q: integer;
  82.  
  83.     begin
  84.         VDI_pb.control^[0]:=130;
  85.         VDI_pb.control^[1]:=0;
  86.         VDI_pb.control^[3]:=1;
  87.         VDI_pb.control^[6]:=handle;
  88.         VDI_pb.intin^[0]:=element_num;
  89.         vdi(@VDI_pb);
  90.         index:=VDI_pb.intout^[0];
  91.         name:='';
  92.         for q:=1 to 32 do name:=name+chr(VDI_pb.intout^[q]);
  93.         StrPTrim(name);
  94.         vqt_name:=(VDI_pb.intout^[33]=1)
  95.     end;
  96.  
  97.  
  98. procedure SpResource; external; {$L spdotest.o}
  99.  
  100.  
  101. procedure TSpApplication.SetupVDI;
  102.  
  103.     begin
  104.         Attr.Style:=Attr.Style or as_LoadFonts;
  105.         inherited SetupVDI;
  106.         vswr_mode(vdiHandle,MD_TRANS);
  107.         vst_alignment(vdiHandle,TA_LEFT,TA_ASCENT,GP.horAlign,GP.verAlign);
  108.         fntColor:=Blue;
  109.         vst_color(vdiHandle,fntColor)
  110.     end;
  111.  
  112.  
  113. procedure TSpApplication.InitInstance;
  114.  
  115.     begin
  116.         InitResource(@SpResource,nil);
  117.         LoadMenu(SPMENU);
  118.         new(PAbout,Init(@self,K_CTRL,Ctrl_A,SPABOUT,SPTITLE1));
  119.         new(PAttr,Init(@self,K_CTRL,Ctrl_T,SPATTR,SPTITLE3));
  120.         new(PFont,Init(@self,K_CTRL,Ctrl_Z,SPFONT,SPTITLE3));
  121.         inherited InitInstance;
  122.         SetQuit(SPQUIT,SPTITLE2)
  123.     end;
  124.  
  125.  
  126. procedure TSpApplication.InitMainWindow;
  127.     var q: integer;
  128.  
  129.     begin
  130.         if not(SpeedoActive) then
  131.             begin
  132.                 Alert(nil,1,STOP,'SpeedoGDOS ist _nicht_ aktiv!','&Abbruch');
  133.                 Quit
  134.             end
  135.         else
  136.             begin
  137.                 fntIndx:=-1;
  138.                 for q:=1 to (Attr.sysFonts+Attr.addFonts) do
  139.                     if vqt_name(vdiHandle,q,fntName,fntIndx) then break;
  140.                 if fntIndx=-1 then
  141.                     begin
  142.                         Alert(nil,1,STOP,'Keine Vektorfonts vorhanden!','&Abbruch');
  143.                         Quit
  144.                     end
  145.                 else
  146.                     begin
  147.                         new(PSpWindow,Init(nil,'SpeedoTest'));
  148.                         if (MainWindow=nil) or (ChkError<em_OK) then Status:=em_InvalidMainWindow
  149.                         else
  150.                             begin
  151.                                 MainWindow^.SetSubTitle(' Aktueller Font: '+fntName);
  152.                                 PSpWindow(MainWindow)^.oldWidth:=-1;
  153.                                 vst_font(vdiHandle,fntIndx)
  154.                             end
  155.                     end
  156.             end
  157.     end;
  158.  
  159.  
  160. function TSpWindow.CanClose: boolean;
  161.  
  162.     begin
  163.         CanClose:=false;
  164.         if inherited CanClose then
  165.             CanClose:=(Application^.Alert(nil,1,WAIT,'Wollen Sie "SpeedoTest" wirklich verlassen?','&Ja| &Nein ')=1)
  166.     end;
  167.  
  168.  
  169. procedure TSpWindow.GetWindowClass(var AWndClass: TWndClass);
  170.  
  171.     begin
  172.         inherited GetWindowClass(AWndClass);
  173.         with AWndClass do Style:=Style or cs_FullRedraw or cs_WorkBackground;
  174.         ts[0]:='ObjectGEM';
  175.         ts[1]:='für Pure Pascal';
  176.         ts[2]:='Softdesign ''94'
  177.     end;
  178.  
  179.  
  180. function TSpWindow.GetClassName: string;
  181.  
  182.     begin
  183.         GetClassName:='SpeedoTestWindow'
  184.     end;
  185.  
  186.  
  187. procedure TSpWindow.Paint(var PaintInfo: TPaintStruct);
  188.     var dummy,q: integer;
  189.         array8 : ARRAY_8;
  190.  
  191.     procedure getSize;
  192.         label _fsnew,_fsagain;
  193.  
  194.         var h,abw,old: integer;
  195.  
  196.         begin
  197.             SetSubTitle(' Neue Fontgrößen werden berechnet...');
  198.             BusyMouse;
  199.             ShowMouse;
  200.             fy[0]:=0;
  201.             q:=0;
  202.             repeat
  203.                 fy[q+1]:=fy[q];
  204.                 abw:=5;
  205.                 _fsnew:
  206.                 h:=round(Application^.Attr.MaxPX*(Application^.Attr.PixW/1000));
  207.                 fs[q]:=h shr 1;
  208.                 old:=0;
  209.                 _fsagain:
  210.                 vst_arbpt(vdiHandle,fs[q],dummy,dummy,dummy,dummy);
  211.                 vqt_f_extent(vdiHandle,ts[q],array8);
  212.                 dummy:=array8[2]-array8[0];
  213.                 if not(Between(dummy,Work.W-abw,Work.W+abw)) and not(bTst(Kbshift(-1),1)) then
  214.                     begin
  215.                         if fs[q]=old then
  216.                             begin
  217.                                 inc(abw,5);
  218.                                 goto _fsnew
  219.                             end;
  220.                         if dummy<Work.W then
  221.                             begin
  222.                                 old:=fs[q];
  223.                                 fs[q]:=(fs[q]+h) shr 1;
  224.                                 goto _fsagain
  225.                             end
  226.                         else
  227.                             begin
  228.                                 old:=fs[q];
  229.                                 h:=fs[q];
  230.                                 fs[q]:=fs[q] shr 1;
  231.                                 goto _fsagain
  232.                             end
  233.                     end;
  234.                 offs[q]:=-array8[0];
  235.                 inc(q);
  236.                 fy[q]:=fy[q]+array8[7]-array8[1]
  237.             until q>2;
  238.             HideMouse;
  239.             ArrowMouse;
  240.             SetSubTitle(' Aktueller Font: '+SpApp.fntName);
  241.             oldWidth:=Work.W
  242.         end;
  243.  
  244.     begin
  245.         if Work.W<>oldWidth then getSize;
  246.         for q:=0 to 2 do
  247.             begin
  248.                 vst_arbpt(vdiHandle,fs[q],dummy,dummy,dummy,dummy);
  249.                 v_ftext(vdiHandle,Work.X+offs[q],Work.Y+fy[q],ts[q]);
  250.             end
  251.     end;
  252.  
  253.  
  254. procedure TSpWindow.WMClick(mX,mY,KStat: integer);
  255.     var pu     : PPopup;
  256.         q,w,ret: integer;
  257.         idxs   : array [0..8] of integer;
  258.         nam    : array [0..8] of string;
  259.  
  260.     begin
  261.         new(pu,Init(@self,SPPOP,SPPOPUP));
  262.         if pu<>nil then
  263.             begin
  264.                 with pu^ do
  265.                     begin
  266.                         pX:=mX;
  267.                         pY:=mY;
  268.                         pFlag:=POP_CENTER;
  269.                         for q:=0 to 8 do
  270.                             begin
  271.                                 SetText(q,'  -------------------------------- ');
  272.                                 Uncheck(q);
  273.                                 Disable(q)
  274.                             end;
  275.                         w:=0;
  276.                         for q:=1 to (Application^.Attr.sysFonts+Application^.Attr.addFonts) do
  277.                             if vqt_name(vdiHandle,q,nam[w],ret) then
  278.                                 begin
  279.                                     Enable(w);
  280.                                     SetText(w,'  '+nam[w]+StrPSpace(33-length(nam[w])));
  281.                                     if ret=SpApp.fntIndx then Check(w);
  282.                                     idxs[w]:=ret;
  283.                                     inc(w);
  284.                                     if w=9 then break
  285.                                 end;
  286.                         ret:=Execute
  287.                     end;
  288.                 dispose(pu,Done);
  289.                 if ret>=0 then
  290.                     if idxs[ret]<>SpApp.fntIndx then
  291.                         begin
  292.                             SpApp.fntIndx:=idxs[ret];
  293.                             SpApp.fntName:=nam[ret];
  294.                             oldWidth:=-1;
  295.                             vst_font(vdiHandle,idxs[ret]);
  296.                             SetSubTitle(' Aktueller Font: '+nam[ret]);
  297.                             ForceRedraw
  298.                         end
  299.             end
  300.     end;
  301.  
  302.  
  303. procedure TSpWindow.GetWorkMin(var minX,minY: integer);
  304.  
  305.     begin
  306.         inherited GetWorkMin(minX,minY);
  307.         inc(minX,50);
  308.         inc(minY,40)
  309.     end;
  310.  
  311.  
  312. function TSpDialog.GetStyle: integer;
  313.  
  314.     begin
  315.         GetStyle:=inherited GetStyle or SIZER or FULLER
  316.     end;
  317.  
  318.  
  319. procedure TSpDialog.WMClosed;
  320.  
  321.     begin
  322.         if CanClose then
  323.             if Cancel then Destroy
  324.     end;
  325.  
  326.  
  327. function TSpDialog.OK: boolean;
  328.     var q: integer;
  329.  
  330.     begin
  331.         inherited OK;
  332.         OK:=IsModal;
  333.         SpApp.fntColor:=0;
  334.         while TransRec.fc[SpApp.fntColor]=bf_Unchecked do inc(SpApp.fntColor);
  335.         vst_color(vdiHandle,SpApp.fntColor);
  336.         q:=0;
  337.         while TransRec.bc[q]=bf_Unchecked do inc(q);
  338.         Application^.MainWindow^.Class.hbrBackground:=succ(q);
  339.         Application^.MainWindow^.ForceRedraw
  340.     end;
  341.  
  342.  
  343. function TSpDialog.Cancel: boolean;
  344.     var valid: boolean;
  345.  
  346.     begin
  347.         valid:=inherited Cancel;
  348.         if valid then okBtn^.Enable;
  349.         Cancel:=valid
  350.     end;
  351.  
  352.  
  353. function TSpDialog.Help: boolean;
  354.  
  355.     begin
  356.         Application^.Alert(@self,1,NO_ICON,'In dieser Dialogbox werden die Schriftattribute eingestellt. Die neuen Werte werden übernommen, wenn Sie '#174'Setzen'#175' anklicken. Ist der Dialog nichtmodal, bleibt er auch nach dem Setzen aktiv!','  &OK  ');
  357.         Help:=false
  358.     end;
  359.  
  360.  
  361. procedure TSpDialog.CallChanged(Indx: integer; dclk,edt,push: boolean);
  362.     var tr   : TTransRec;
  363.         op   : pointer;
  364.         q1,q2: integer;
  365.  
  366.     begin
  367.         inherited CallChanged(Indx,dclk,edt,push);
  368.         op:=TransferBuffer;
  369.         TransferBuffer:=@tr;
  370.         TransferData(tf_GetData);
  371.         TransferBuffer:=op;
  372.         q1:=0;
  373.         while tr.fc[q1]=bf_Unchecked do inc(q1);
  374.         q2:=0;
  375.         while tr.bc[q2]=bf_Unchecked do inc(q2);
  376.         if q1=q2 then okBtn^.Disable
  377.         else
  378.             okBtn^.Enable
  379.     end;
  380.  
  381.  
  382. procedure TAbout.Work;
  383.  
  384.     begin
  385.         if ADialog=nil then
  386.             begin
  387.                 new(ADialog,Init(nil,'Über SpeedoTest',SABOUT));
  388.                 if ADialog<>nil then
  389.                     begin
  390.                         new(PGroupBox,Init(ADialog,IGROUP,'ObjectGEM SpeedoTest','"42"'));
  391.                         new(PButton,Init(ADialog,IOK,id_OK,true,'Mit diesem '+
  392.                                             'Button|kann die Infobox|verlassen werden.'))
  393.                     end
  394.             end;
  395.         if ADialog<>nil then ADialog^.MakeWindow
  396.     end;
  397.  
  398.  
  399. procedure TAttr.Work;
  400.     var q: integer;
  401.  
  402.     begin
  403.         if ADialog=nil then
  404.             begin
  405.                 ADialog:=new(PSpDialog,Init(nil,'Attribute',SATTR));
  406.                 if ADialog<>nil then
  407.                     begin
  408.                         new(PGroupBox,Init(ADialog,AFGROUP,'Schrift','Bestimmt die Schriftfarbe.'));
  409.                         new(PGroupBox,Init(ADialog,ABGROUP,'Hintergrund','Bestimmt die Farbe des|Fenster-Hintergrundes.'));
  410.                         new(PRadioButton,Init(ADialog,AFWHITE,true,'Setzt Weiß als|neue Schriftfarbe'));
  411.                         new(PRadioButton,Init(ADialog,AFBLACK,true,'Setzt Schwarz als|neue Schriftfarbe'));
  412.                         new(PRadioButton,Init(ADialog,AFRED,true,'Setzt Rot als|neue Schriftfarbe'));
  413.                         new(PRadioButton,Init(ADialog,AFGREEN,true,'Setzt Grün als|neue Schriftfarbe'));
  414.                         new(PRadioButton,Init(ADialog,AFBLUE,true,'Setzt Blau als|neue Schriftfarbe'));
  415.                         new(PRadioButton,Init(ADialog,AFCYAN,true,'Setzt Türkis als|neue Schriftfarbe'));
  416.                         new(PRadioButton,Init(ADialog,AFYELLOW,true,'Setzt Gelb als|neue Schriftfarbe'));
  417.                         new(PRadioButton,Init(ADialog,AFMAGENT,true,'Setzt Violett als|neue Schriftfarbe'));
  418.                         new(PRadioButton,Init(ADialog,ABWHITE,true,'Setzt Weiß als|neuen Hintergrund'));
  419.                         new(PRadioButton,Init(ADialog,ABBLACK,true,'Setzt Schwarz als|neuen Hintergrund'));
  420.                         new(PRadioButton,Init(ADialog,ABRED,true,'Setzt Rot als|neuen Hintergrund'));
  421.                         new(PRadioButton,Init(ADialog,ABGREEN,true,'Setzt Grün als|neuen Hintergrund'));
  422.                         new(PRadioButton,Init(ADialog,ABBLUE,true,'Setzt Blau als|neuen Hintergrund'));
  423.                         new(PRadioButton,Init(ADialog,ABCYAN,true,'Setzt Türkis als|neuen Hintergrund'));
  424.                         new(PRadioButton,Init(ADialog,ABYELLOW,true,'Setzt Gelb als|neuen Hintergrund'));
  425.                         new(PRadioButton,Init(ADialog,ABMAGENT,true,'Setzt Violett als|neuen Hintergrund'));
  426.                         new(PButton,Init(ADialog,AHELP,id_Help,true,'Zeigt einen Hilfstext|über diesen Dialog an.'));
  427.                         new(PSpDialog(ADialog)^.okBtn,Init(ADialog,AOK,id_OK,true,'Setzt die neuen Attribute,|_ohne_ den Dialog zu ver-|lassen.'));
  428.                         new(PButton,Init(ADialog,ACANCEL,id_Cancel,true,'Bricht den Dialog ab,|ohne die neuen Werte|zu übernehmen.'));
  429.                         with PSpDialog(ADialog)^ do
  430.                             begin
  431.                                 TransferBuffer:=@TransRec;
  432.                                 with TransRec do
  433.                                     begin
  434.                                         for q:=0 to 7 do
  435.                                             begin
  436.                                                 fc[q]:=bf_Unchecked;
  437.                                                 bc[q]:=bf_Unchecked
  438.                                             end;
  439.                                         fc[SpApp.fntColor]:=bf_Checked;
  440.                                         bc[pred(Application^.MainWindow^.Class.hbrBackground)]:=bf_Checked
  441.                                     end
  442.                             end
  443.                     end
  444.             end;
  445.         if ADialog<>nil then ADialog^.MakeWindow
  446.     end;
  447.  
  448.  
  449. procedure TFont.Work;
  450.     var x,y,bs,ks: integer;
  451.  
  452.     begin
  453.         graf_mkstate(x,y,bs,ks);
  454.         Application^.MainWindow^.WMClick(x,y,ks)
  455.     end;
  456.  
  457.  
  458. begin
  459.     SpApp.Init('STST','SpeedoTest');
  460.     SpApp.Run;
  461.     SpApp.Done
  462. end.